home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / trans3.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  12.2 KB  |  350 lines
  1. ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;     The data in this file contains enhancments.                    ;;;;;
  4. ;;;                                                                    ;;;;;
  5. ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
  6. ;;;     All rights reserved                                            ;;;;;
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  9. ;;;       (c) Copyright 1980 Massachusetts Institute of Technology       ;;;
  10. ;;;       Maintained by GJC                                              ;;;
  11. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  12.  
  13. (in-package "MAXIMA")
  14. (macsyma-module trans3)
  15.  
  16. (TRANSL-MODULE TRANS3)
  17.  
  18. (declare-top(*lexpr sum-var-sets)
  19.      (genprefix trans3_))
  20.  
  21. ;;; The translation of macsyma LAMBDA into lexicaly scoped closures.
  22. ;;; Two cases [1] the downward transmission of variable binding environment,
  23. ;;; e.g. MAP(LAMBDA([U],F(U,X)),EXP)
  24. ;;; [2] downward and upward, requiring a full closure, e.g.
  25. ;;; MAP(LAMBDA([U],SUM:SUM+U),EXP);
  26.  
  27. ;;; LAMBDA([U],F(U,X)) =>
  28. ;;; (DOWN-CLOSE (LAMBDA (U) (F U X)) (X))
  29.  
  30. ;;; TBIND, TBOUNDP, and TUNBIND and TUNBINDS hack lexical scoping.
  31.  
  32. ;;; A function to determine free vars from a lisp expression.
  33. ;;; It returns a <var-set> which is a list of pairs
  34. ;;; (<var> . <side-effectp>)
  35.  
  36. ;;; N.B. This code does a veritable storm of consing, it need not
  37. ;;; do any if it used the lambda-bound plist scheme of GJC;UTRANS >
  38. ;;; a compiler is allowed to cons though, isn't it?
  39.  
  40. (DEFTRFUN FREE-LISP-VARS (EXP &AUX PROP)
  41.        (COND ((ATOM EXP)
  42.           (COND ((OR (NULL EXP)(EQ T EXP)) NIL)
  43.             ((SYMBOLP EXP) `((,EXP . NIL)))
  44.             (T NIL)))
  45.          ((ATOM (CAR EXP))
  46.           (COND ((SETQ PROP (GET (CAR EXP) 'FREE-LISP-VARS))
  47.              (FUNCALL PROP EXP))
  48.             ((setq prop (get (car exp) 'free-lisp-vars-macro))
  49.              (free-lisp-vars (funcall prop exp)))
  50.             ((SETQ PROP (GET (CAR EXP) 'MACRO))
  51.              (FREE-LISP-VARS (FUNCALL PROP EXP)))
  52.             ((GETL (CAR EXP) '(FSUBR FEXPR))
  53.              (WARN-FEXPR (CAR EXP)
  54.                  "environment may fail to be correct.")
  55.              (FREE-LISP-VARS-OF-ARGL (CDR EXP)))
  56.             (T
  57.              (FREE-LISP-VARS-OF-ARGL (CDR EXP)))))
  58.          ((EQ (CAAR EXP) 'LAMBDA)
  59.           (SUM-VAR-SETS (FREE-LISP-VARS (CAR EXP))
  60.                 (FREE-LISP-VARS-OF-ARGL (CDR EXP))))
  61.          (T
  62.           (BARFO "Bad lisp expression generated."))))
  63.  
  64.  
  65. (DEFUN FREE-LISP-VARS-OF-ARGL (ARGL)
  66.        (UNION-VAR-SET (MAPCAR #'FREE-LISP-VARS ARGL)))
  67.  
  68. ;;; (REDUCE-VAR-SET '((A . NIL) NIL (B . T) (B . NIL))) => ((A . NIL) (B . T))
  69. ;;;  mult-set reduction.
  70.  
  71. (DEFUN REDUCE-VAR-SET&OP (VAR-SET OP)
  72.        (DO ((VAR-SET VAR-SET (CDR VAR-SET))
  73.         (REDUCED-VAR-SET NIL)
  74.         (VAR1)
  75.         (VAR2))
  76.        ((NULL VAR-SET) REDUCED-VAR-SET)
  77.        (SETQ VAR1 (CAR VAR-SET))
  78.        (COND ((NULL VAR1))
  79.          ((SETQ VAR2 (ASSQ (CAR VAR1) REDUCED-VAR-SET))
  80.           (RPLACD VAR2 (FUNCALL OP (CDR VAR1) (CDR VAR2))))
  81.          (T
  82.           (PUSH VAR1 REDUCED-VAR-SET)))))
  83.  
  84.  
  85. (DEFUN REDUCE-VAR-SET (VAR-SET)
  86.        (REDUCE-VAR-SET&OP VAR-SET #'(LAMBDA (P1 P2)(OR P1 P2))))
  87.  
  88. ;;; S1 - S2. S1 reduced, minus any vars that are in S2.
  89.  
  90. (DEFUN DIFFERENCE-VAR-SETS (S1 S2)
  91.        (SETQ S1 (REDUCE-VAR-SET S1))
  92.        (DO ((S NIL))
  93.        ((NULL S1) S)
  94.        (COND ((ASSQ (CAAR S1) S2)) ;;; is the first elem of S1 a member of S2?
  95.          (T
  96.           (PUSH (CAR S1) S)))  ;;; yes. shove it in.
  97.        (POP S1)))
  98.  
  99. ;;; N.B. union of var sets is defined classicaly ala G.F.
  100.  
  101. (DEFUN UNION-VAR-SET (SET-OF-VAR-SETS)
  102.        (REDUCE-VAR-SET (APPLY #'APPEND SET-OF-VAR-SETS)))
  103.  
  104. ;;; SUM-VAR-SETS is the usual convention.
  105.  
  106. (DEFUN SUM-VAR-SETS (&REST L)
  107.        (REDUCE-VAR-SET (APPLY #'APPEND L))) ; consing up a storm aren't we?
  108.  
  109. (DEFUN MAKE-VAR-SET (VARS)
  110.        (sloop for v in vars collect (ncons v)))
  111.  
  112. ;;; (LAMBDA <BVL> . <BODY>)
  113.  
  114. (DEFUN-prop (LAMBDA FREE-LISP-VARS) (FORM)
  115.        (DIFFERENCE-VAR-SETS (FREE-LISP-VARS-OF-ARGL (CDDR FORM))
  116.                 (COND ((NULL (CADR FORM))
  117.                    NIL)
  118.                   ((ATOM (CADR FORM))
  119.                    (MAKE-VAR-SET (LIST (CADR FORM))))
  120.                   (T
  121.                    (MAKE-VAR-SET (CADR FORM))))))
  122.  
  123. ;;; (PROG <BVL> . <BODY>)
  124.  
  125. (DEFUN-prop (PROG FREE-LISP-VARS) (FORM)
  126.        (DIFFERENCE-VAR-SETS (UNION-VAR-SET
  127.                  (MAPCAR #'(LAMBDA (U)
  128.                            (COND ((ATOM U) NIL) ;; go tag.
  129.                              (T
  130.                               (FREE-LISP-VARS U))))
  131.                      (CDDR FORM)))
  132.                 (MAKE-VAR-SET (CADR FORM))))
  133.  
  134. ;;; no computed gos please.
  135. (DEFUN-prop (GO FREE-LISP-VARS) (IGNOR)IGNOR NIL)
  136.  
  137.  
  138.  
  139. ;;; (DO ((<V> <V> <V>) ...) ((<in-scope>) ..) ...)
  140.  
  141. (DEFUN-prop (DO FREE-LISP-VARS) (FORM)
  142.        (DIFFERENCE-VAR-SETS
  143.     (SUM-VAR-SETS (FREE-LISP-VARS-OF-ARGL (CDDDR FORM))
  144.               (FREE-LISP-VARS-OF-ARGL (CADDR FORM))
  145.               (UNION-VAR-SET (MAPCAR #'(LAMBDA (DO-ITER)
  146.                                (FREE-LISP-VARS-OF-ARGL 
  147.                             (CDR DO-ITER)))
  148.                          (CADR FORM))))
  149.     (MAKE-VAR-SET (MAPCAR #'CAR (CADR FORM)))))
  150.  
  151.  
  152. ;;; (COND (<I> ..) (<J> ..) ...)
  153.  
  154. (DEFUN-prop (COND FREE-LISP-VARS) (FORM)
  155.        (UNION-VAR-SET (MAPCAR #'FREE-LISP-VARS-OF-ARGL (CDR FORM))))
  156.                   
  157.  
  158. (DEFUN-prop (QUOTE FREE-LISP-VARS) (IGNOR)IGNOR NIL)
  159. (DEFUN-prop (FUNCTION FREE-LISP-VARS) (IGNOR)IGNOR NIL)
  160.  
  161. ;;; (SETQ ... ODD AND EVENS...)
  162.  
  163. (DEFUN-prop (SETQ FREE-LISP-VARS) (FORM)
  164.        (DO ((FREE-VARS NIL (SUM-VAR-SETS `((,(CAR FORM) . T))
  165.                      (FREE-LISP-VARS (CADR FORM))
  166.                      FREE-VARS))
  167.         (FORM (CDR FORM) (CDDR FORM)))
  168.        ((NULL FORM) FREE-VARS)))
  169.  
  170. ;;; uhm. LAMBDA, PROG, GO, DO, COND, QUOTE, SETQ.
  171.  
  172. (DEFUN-prop (AND FREE-LISP-VARS)(FORM)(FREE-LISP-VARS-OF-ARGL (CDR FORM)))
  173. (DEFUN-prop (OR FREE-LISP-VARS)(FORM)(FREE-LISP-VARS-OF-ARGL (CDR FORM)))
  174.  
  175. (DEFUN-prop (COMMENT FREE-LISP-VARS) (IGNOR)IGNOR NIL)
  176. (DEFUN-prop (DECLARE FREE-LISP-VARS) (IGNOR) IGNOR NIL)
  177.  
  178. ;;; these next forms are generated by TRANSLATE.
  179.  
  180. (DEFPROP $PIECE T SORT-OF-LEXICAL)
  181.  
  182. (defun-prop (trd-msymeval free-lisp-vars) (FORM)
  183.   (IF (GET (CADR FORM) 'SORT-OF-LEXICAL)
  184.       ;; acts like a lexical variable because of the $SUBSTPART translator.
  185.       (LIST (LIST (CADR FORM)))
  186.       ()))
  187.  
  188. (DEFUN-prop (MFUNCTION-CALL FREE-LISP-VARS) (FORM)
  189.        ; it is not strictly known if the name of the function being called
  190.        ; is a variable or not. lets say its not.
  191.        (FREE-LISP-VARS-OF-ARGL (CDDR FORM)))
  192.  
  193. ;;; (FUNGEN&ENV-FOR-MEVAL () () EXP)
  194. (DEFUN-prop (FUNGEN&ENV-FOR-MEVAL FREE-LISP-VARS) (FORM)
  195.        (FREE-LISP-VARS (CAR (CDDDr form))))
  196. ;;; (FUNGEN&ENV-FOR-MEVALSUMARG () () EXP MACSYMA-EXP)
  197. (DEFUN-prop (FUNGEN&ENV-FOR-MEVALSUMARG FREE-LISP-VARS) (FORM)
  198.        (FREE-LISP-VARS (CAR (CDDR form))))
  199. ;;; the various augmented lambda forms.
  200.  
  201. (DEFUN free-lisp-vars-m-tlambda (FORM)
  202.        (DIFFERENCE-VAR-SETS (FREE-LISP-VARS-OF-ARGL (CDDR FORM))
  203.                 (FREE-LISP-VARS-OF-ARGL (CADR FORM))))
  204. (MAPC #'(LAMBDA (U)(PUTPROP U 'FREE-LISP-VARS-m-tLAMBDA 'FREE-LISP-VARS))
  205.       '(M-TLAMBDA M-TLAMBDA&))
  206. (defun free-lisp-vars-m-tlambda&env (form)
  207.        (difference-var-sets (free-lisp-vars-of-argl (cddr form))
  208.                 (free-lisp-vars-of-argl (car (cadr form)))))
  209. (defprop m-tlambda&env free-lisp-vars-m-tlambda&env free-lisp-vars)
  210. (defprop m-tlambda&env& free-lisp-vars-m-tlambda&env free-lisp-vars)
  211. ; (m-tlambda-i mode env ...)
  212. (defun-prop (m-tlambda-i free-lisp-vars-macro) (form)
  213.        `(lambda ,@(cdddr form)))
  214.  
  215.  
  216. ;;; Other entry points: 
  217.  
  218. (DEFUN TBOUND-FREE-VARS (FREE-VARL)
  219.        ; Takes a FREE-VAR list and returns a list of two lists.
  220.        ; the tbound free vars and the tbound free vars that are
  221.        ; side effected also.
  222.        (DO ((FREE NIL)
  223.         (FREE&S NIL))
  224.        ((NULL FREE-VARL) (LIST FREE FREE&S))
  225.        (LET ((V (POP FREE-VARL)))
  226.         (COND ((AND (TBOUNDP (CAR V))
  227.                 (NOT (GET (CAR V) 'SPECIAL)))
  228.                (PUSH (CAR V) FREE)
  229.                (COND ((CDR V)
  230.                   (PUSH (CAR V) FREE&S))))))))
  231.  
  232. (DEFUN SIDE-EFFECT-FREE-CHECK (VARL FORM)
  233.        (COND ((NULL VARL) T)
  234.          (T
  235.           (TR-TELL "This form:" FORM
  236.                   "has side effects on these variables:"
  237.                   `((MLIST) ,@VARL)
  238.                   "which cannot be supported in the translated code."
  239.                   "(at this time)")
  240.          NIL)))
  241.  
  242.  
  243. ;;; O.K. here is the translate property for LAMBDA.
  244. ;;; given catch and throw we don't know where a funarg lambda
  245. ;;; may end up.
  246.  
  247. ;;; Cases:
  248. ;;; I. No side effects on free variables.
  249. ;;;    A. one funarg only, not reconsed. e.g.
  250. ;;;       F(N,L):=MAP(LAMBDA([U],Q(N,U)),L)$
  251. ;;;       (PROGN (SET-ENV <*LINK*> N)
  252. ;;;              (FUNCTION (LAMBDA (U) (LET ((N (GET-ENV *LINK*))) (f* U N)))))
  253. ;;;    B. need new instance of the environment each time,
  254. ;;;       F(N):=LAMBDA([U],N*U);
  255. ;;;       `(LAMBDA (U) (gen-func U 'N)) without extend loaded.
  256. ;;; II. side effects.
  257. ;;;    A. Those since effects need to be propogated to the environment
  258. ;;;       where the LAMBDA was made. This is difficult to do in the
  259. ;;;       present translator. e.g.
  260. ;;;       F(L):=BLOCK([SUM:0],FULLMAP(LAMBDA([U],SUM:SUM+U),L),SUM);
  261. ;;;       every function which guarantees the order of argument evalation
  262. ;;;       (MPROG and MPROGN), must translate and expression and get information
  263. ;;;       about environment propagation. 
  264. ;;;       (PROGN (FULLMAP (PROGN (SET-ENV) '(LAMBDA ...)) L)
  265. ;;;              (GET-ENV)), uhm. this is pretty tricky anyway.
  266. ;;;    B. side effects only have to be maintained inside the LAMBDA.
  267. ;;;       this is easier, and if you have it, you really don't need II.A.
  268. ;;;       since you can always ask the LAMBDA for its environment by
  269. ;;;       calling it on the proper message {If the LAMBDA is written that way}.
  270.  
  271. ;;; LAMBDA-I is used by ROMBERG, PLOT2 and INTERPOLATE, and it could be used
  272. ;;; by the mapping functions. We have a single instance of the LAMBDA
  273. ;;; and its environment.
  274.  
  275.  
  276. ;;; ((LAMBDA) ((MLIST) X Y ((MLIST Z))) . <BODY>)
  277. ;;; must also handle the &REST arguments. N.B. MAPPLY correctly handles
  278. ;;; the application of a lisp lambda form.
  279.  
  280.  
  281. ;;; Some forms know that the lambda is not going to
  282. ;;; be an upward funarg, that it is not possible (wanted)
  283. ;;; have two different lambda's generated from the same
  284. ;;; place. e.g. INTERPOLATE(SIN(X^2)=A,X,0,N) (implied lambda
  285. ;;; which is contructed by the translation property for
  286. ;;; interpolate. MAP(LAMBDA([U],...),L) is another example)
  287. ;;; these forms will be called I-LAMBDA's, and will be generated
  288. ;;; from LAMBDA's by the functions that want to. All this
  289. ;;; is meaningless in the present macsyma evaluator of course, since
  290. ;;; it uses dynamic binding and just hopes for the best.
  291.  
  292. (DEF%TR $LAMBDA_I (FORM)
  293.     (GEN-TR-LAMBDA FORM))
  294. (def%tr lambda-I (form) (gen-tr-lambda form))
  295. (DEF%TR LAMBDA (FORM)
  296.     (GEN-TR-LAMBDA FORM))
  297.  
  298. ;;; we keep a pointer to the original FORM so that we can
  299. ;;; generate messages with it if need be.
  300.  
  301. (DEFUN GEN-TR-LAMBDA (FORM &AUX ARG-INFO MODE FREES T-FORM)
  302.     (SETQ ARG-INFO (MAPCAR #'(LAMBDA (V)
  303.                      (COND ((ATOM V) NIL)
  304.                            ((AND (EQ (CAAR V) 'MLIST)
  305.                              (ATOM (CADR V)))
  306.                         T)
  307.                            (T '*BAD*)))
  308.                    (CDR (CADR FORM))))
  309.     (COND ((OR (MEMQ '*BAD* ARG-INFO)
  310.            (AND (MEMQ T ARG-INFO) 
  311.             (CDR (MEMQ T ARG-INFO)))) ;;; the &REST is not the last one.
  312.            (TR-TELL (CADR FORM) " bad LAMBDA list. -TRANSLATE")
  313.            (SETQ TR-ABORT T)
  314.            NIL)
  315.           (T
  316.            (SETQ ARG-INFO (MEMQ T ARG-INFO) ;; &RESTP
  317.              T-FORM
  318.              (TR-LAMBDA `((LAMBDA)
  319.                   ((MLIST) ,@(MAPCAR #'(LAMBDA (V)
  320.                                    (COND ((ATOM V) V)
  321.                                      (T (CADR V))))
  322.                              (CDR (CADR FORM))))
  323.                   ,@(CDDR FORM)))
  324.              MODE (CAR T-FORM)   ; not much to do with the mode now,
  325.              T-FORM (CDR T-FORM) ; could be use by a global optimizer.
  326.              FREES (TBOUND-FREE-VARS (FREE-LISP-VARS T-FORM)))))
  327.     ; with this info we now dispatch to the various macros forms.
  328.     ; (cadr t-form) is a lambda list. (cddr t-form) is a progn body.
  329.     (COND ((NULL (CAR FREES)) ; woopie.
  330.            (COND ((NULL ARG-INFO)
  331.               `($ANY . (M-TLAMBDA ,@(CDR T-FORM))))
  332.              (T
  333.              `($ANY . (M-TLAMBDA& ,@(CDR T-FORM))))))
  334.           ((NULL (CADR FREES))
  335.            (COND ((EQ (CAAR FORM) 'LAMBDA-I)
  336.               `($ANY . (M-TLAMBDA-I ,MODE ,(CAR FREES) ,@(CDR T-FORM))))
  337.              (T
  338.               `($ANY . (,(COND ((NULL ARG-INFO) 'M-TLAMBDA&ENV)
  339.                        (T               'M-TLAMBDA&ENV&))
  340.                 (,(CADR T-FORM) ,(CAR FREES))
  341.                 ,@(CDDR T-FORM))))))
  342.           (T
  343.            (WARN-MEVAL FORM)
  344.            (side-EFFECT-FREE-CHECK (CADR FREES) FORM)
  345.            `($ANY . (MEVAL ',FORM)))))
  346.  
  347.            
  348.  
  349.  
  350.